home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Atari Mega Archive 1
/
Atari Mega Archive - Volume 1.iso
/
language
/
examples.zoo
/
misc
/
sort2.lsp
< prev
Wrap
Lisp/Scheme
|
1991-10-22
|
2KB
|
41 lines
; Eine Sortierfunktion, sortiert eine Liste und streicht dabei Doppelte.
; Für list destruktiv.
; comparefun realisiert eine Totalordnung: -1 oder 0 oder +1 als Ergebnis.
; Dabei gelten zwei Listenelemente als gleich, wenn comparefun 0 liefert.
(defun sort-list-deleting-duplicates (list comparefun &key (key #'identity))
(if (endp list)
list ; leere Liste unverändert
(labels ((sort-part (list)
(let ((len (length list)))
(case len
(1 list) ; einelementige Liste unverändert
(2 (case (funcall comparefun (funcall key (first list)) (funcall key (second list)))
(-1 list) ; Liste ist bereits sortiert
(0 (cdr list)) ; zwei gleiche, wird verkürzt
(+1 (setf (cddr list) list) (shiftf (cdr list) nil)) ; vertauschen
) )
(t ; Liste mit >=2 Elementen
; auseinanderdividieren in zwei Teile:
(let ((L1 list)
(L2 (shiftf (cdr (nthcdr (1- (ash len -1)) list)) nil)))
; einzeln sortieren:
(setq L1 (sort-part L1))
(setq L2 (sort-part L2))
; Nun sind L1 und L2 (jedes für sich) sortiert und ohne Doppelte.
; zusammenmischen, dabei sortiert halten und gemeinsame Elemente
; von L1 und L2 nur einmal übernehmen (dadurch enthält dann
; auch die Gesamtliste keine Doppelten):
(setq list nil)
(loop
(when (null L1) (return (nreconc list L2)))
(when (null L2) (return (nreconc list L1)))
(case (funcall comparefun (funcall key (first L1)) (funcall key (first L2)))
(-1 (rotatef list L1 (cdr L1)))
(0 (pop L1) (rotatef list L2 (cdr L2)))
(+1 (rotatef list L2 (cdr L2)))
) )
)) ) ) ) )
(sort-part list)
) ) )